home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Infixst.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  3.4 KB  |  104 lines  |  [TEXT/R*ch]
  1. (* This file has been derived from the ML Kit. *)
  2.  
  3. open Fnlib Mixture Const Globals Location Asynt;
  4.  
  5. exception WrongInfix;
  6. exception MixedAssociativity;
  7.  
  8. type 'Obj InfixStackStr = {
  9.     applyId : IdInfo -> 'Obj -> 'Obj,
  10.     applyObj : 'Obj -> 'Obj -> 'Obj,
  11.     asId : 'Obj -> IdInfo option,
  12.     pair : 'Obj -> 'Obj -> 'Obj
  13. };
  14.  
  15. datatype StackEntry =
  16.     INFIXentry of IdInfo * int
  17.   | INFIXRentry of IdInfo * int
  18.   | APPentry
  19. ;
  20.  
  21. datatype LastObj = ARG | OPER | VOID;
  22.  
  23. fun resolveInfix (iStackStr : 'Obj InfixStackStr) statusOfId objs =
  24.  
  25.   let 
  26.     val { pair, asId, applyId, applyObj } = iStackStr
  27.  
  28.     fun apply entry (o2 :: o1 :: rest) =
  29.           let val thePair = pair o1 o2 in
  30.             ( case entry of
  31.                   INFIXentry(ii, n) => applyId ii thePair
  32.                 | INFIXRentry(ii, n) => applyId ii thePair
  33.                 | APPentry => applyObj o1 o2
  34.             ) :: rest
  35.           end
  36.       | apply entry output =
  37.           raise WrongInfix
  38.  
  39.     and assocLeft APPentry _ = true
  40.       | assocLeft _ APPentry = false
  41.       | assocLeft op1 op2 =
  42.           let fun extract (INFIXentry(_, n))  = (n, true)
  43.                 | extract (INFIXRentry(_, n)) = (n, false)
  44.                 | extract _ = raise WrongInfix
  45.               val (prec1, left1) = extract op1
  46.               val (prec2, left2) = extract op2 
  47.           in
  48.             if prec1 > prec2 then true
  49.             else if prec1 < prec2 then false
  50.             else if left1 = left2 then left1
  51.             else raise MixedAssociativity
  52.       end
  53.  
  54.     and flushHigher entry stack output =
  55.       case stack of
  56.           [] => ([], output)
  57.         | top :: rest =>
  58.             if assocLeft top entry then
  59.               flushHigher entry rest (apply top output)
  60.             else
  61.               (stack, output)
  62.  
  63.     and flushAll stack output =
  64.       case stack of
  65.           [] => ( case output of
  66.                       [item] => item
  67.                     | _ => raise WrongInfix )
  68.         | top :: rest => flushAll rest (apply top output)
  69.  
  70.     and process input stack last output =
  71.       case input of
  72.           [] =>
  73.             flushAll stack output
  74.         | this :: rest =>
  75.             ( case asId this of
  76.                     SOME ii =>
  77.                       ( case statusOfId (#id(#qualid ii)) of
  78.                             INFIXst n =>
  79.                               operator (INFIXentry(ii,n))
  80.                                         rest stack output
  81.                           | INFIXRst n =>
  82.                               operator (INFIXRentry(ii,n))
  83.                                         rest stack output
  84.                           | NONFIXst =>
  85.                               ( case last of
  86.                                     ARG => operator APPentry
  87.                                                     input stack output
  88.                                   | _ => process rest stack ARG
  89.                                                   (this :: output) ) )
  90.                   | NONE =>
  91.                       ( case last of
  92.                             ARG =>
  93.                               operator APPentry input stack output
  94.                           | _ =>
  95.                               process rest stack ARG (this :: output)
  96.                       ) )
  97.  
  98.     and operator entry input stack output =
  99.       let val (stack', output') = flushHigher entry stack output 
  100.       in process input (entry :: stack') OPER output' end
  101.  
  102.   in process objs [] VOID [] end
  103. ;
  104.